home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Magnum One
/
Magnum One (Mid-American Digital) (Disc Manufacturing).iso
/
d13
/
oct90.arc
/
TIP590.LSP
< prev
next >
Wrap
Text File
|
1990-11-01
|
2KB
|
48 lines
;TIP 590.LSP Trim Short or Long Ends at an Intersection
;(c)1990 Neil Devine
(defun c:ctrim (/ A B P1 P2 S1 E1 E2 L1 L2)
(setvar "menuecho" 0)
(setq A (entsel "\nSelect end to eliminate: "))
(setq B (entsel "\n\n\nSelect end to eliminate: "))
(if (or (= nil A)(= nil B))
(princ "\n\nRoutine requires 2 intersecting lines...")
(progn ;else
(setq P1 (list (caadr A)(cadadr A)(caddar (cdr A)))
P2 (list (caadr B)(cadadr B)(caddar (cdr B)))
S1 (cdr (assoc 10 (setq L1 (entget (car A)))))
E1 (cdr (assoc 11 L1))
S2 (cdr (assoc 10 (setq L2 (entget (car B)))))
E2 (cdr (assoc 11 L2))
I (inters S1 E1 S2 E2 1)
)
(if (= nil I)
(princ "\n\nRoutine requires 2 intersecting lines...")
(progn ;else
(if (< (distance S1 I)(distance S1 P1))
(progn
(setq L1 (subst (cons 11 I)(assoc 11 L1) L1))
(entmod L1)
)
(progn
(setq L1 (subst (cons 10 I)(assoc 10 L1) L1))
(entmod L1)
)
)
(if (< (distance S2 I)(distance S2 P2))
(progn
(setq L2 (subst (cons 11 I)(assoc 11 L2) L2))
(entmod L2)
)
(progn
(setq L2 (subst (cons 10 I)(assoc 10 L2) L2))
(entmod L2)
)
)
)
)
)
)
(princ)
)